home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Aminet 1 (Walnut Creek)
/
Aminet - June 1993 [Walnut Creek].iso
/
aminet
/
util
/
gnu
/
gnu_smalltalk1_2.lha
/
Metaclass.st
< prev
next >
Wrap
Text File
|
1992-02-15
|
9KB
|
290 lines
"======================================================================
|
| MetaClass Method Definitions
|
======================================================================"
"======================================================================
|
| Copyright (C) 1990, 1991, 1992 Free Software Foundation, Inc.
| Written by Steve Byrne.
|
| This file is part of GNU Smalltalk.
|
| GNU Smalltalk is free software; you can redistribute it and/or modify it
| under the terms of the GNU General Public License as published by the Free
| Software Foundation; either version 1, or (at your option) any later version.
|
| GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
| ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
| FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
| details.
|
| You should have received a copy of the GNU General Public License along with
| GNU Smalltalk; see the file COPYING. If not, write to the Free Software
| Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|
======================================================================"
"
| Change Log
| ============================================================================
| Author Date Change
| sbyrne 16 May 90 Changed the implementation of name: ... to try to
| preserve an existing class (if possible). The
| original code exists in newMeta: ...
|
| sbyrne 25 Apr 89 created.
|
"
ClassDescription subclass: #Metaclass
instanceVariableNames: 'instanceClass'
classVariableNames: ''
poolDictionaries: ''
category: nil
!
Metaclass comment:
'I am the root of the class hierarchy. My instances are metaclasses, one for
each real class. My instances have a single instance, which they hold
onto, which is the class that they are the metaclass of. I provide methods
for creation of actual class objects from metaclass object, and the creation
of metaclass objects, which are my instances. If this is confusing to you,
it should be...the Smalltalk metaclass system is strange and complex.' !
!Metaclass class methodsFor: 'instance creation'!
subclassOf: superMeta
| newMeta |
newMeta _ self new.
newMeta superclass: superMeta.
superMeta addSubclass: newMeta.
newMeta initMetaclass.
^newMeta
!!
!Metaclass methodsFor: 'basic'!
name: newName
environment: aSystemDictionary
subclassOf: superclass
instanceVariableNames: stringOfInstVarNames
variable: variableBoolean
words: wordBoolean
pointers: pointerBoolean
classVariableNames: stringOfClassVarNames
poolDictionaries: stringOfPoolNames
category: categoryName
comment: commentString
changed: changed
| aClass variableString variableArray sharedPoolNames poolName pool
className classVarDict oldClassPool |
"Please don't look at this case for an example of how to create good
Smalltalk code. It is inelegantly written and probably highly
inefficient."
className _ newName asSymbol.
aClass _ aSystemDictionary at: className ifAbsent: [ nil ].
aClass isNil
ifTrue: [ ^self newMeta: newName
environment: aSystemDictionary
subclassOf: superclass
instanceVariableNames: stringOfInstVarNames
variable: variableBoolean
words: wordBoolean
pointers: pointerBoolean
classVariableNames: stringOfClassVarNames
poolDictionaries: stringOfPoolNames
category: categoryName
comment: commentString
changed: changed ].
(aClass isVariable == variableBoolean)
& (aClass isWords == wordBoolean )
& (aClass isPointers == pointerBoolean)
ifFalse: [ ^self newMeta: newName
environment: aSystemDictionary
subclassOf: superclass
instanceVariableNames: stringOfInstVarNames
variable: variableBoolean
words: wordBoolean
pointers: pointerBoolean
classVariableNames: stringOfClassVarNames
poolDictionaries: stringOfPoolNames
category: categoryName
comment: commentString
changed: changed ].
"Here we have an existing class, so try hard to leave it alone"
instanceClass _ aClass.
aClass setSuperclass: superclass.
" Fix up meta class link also "
superclass notNil
ifTrue: [ aClass class setSuperclass: superclass class ].
superclass notNil
ifTrue: [ "Inherit instance variables from parent"
variableString _ superclass instanceVariableString
]
ifFalse: [ variableString _ '' ].
variableString _ variableString , stringOfInstVarNames.
variableArray _ self parseVariableString: variableString.
1 to: variableArray size do:
[ :i | variableArray at: i put: (variableArray at: i) asSymbol ].
variableArray = aClass allInstVarNames
ifFalse: [ stdout nextPutAll: 'Recompilation required!'; nl.
"aClass compileAll.
aClass compileAllSubclasses."
"### This should be fixed soon" ].
aClass setInstanceVariables: variableArray.
aClass setInstanceSpec: variableBoolean words: wordBoolean
pointers: pointerBoolean instVars: variableArray size.
classVarDict _ (self parseToDict: stringOfClassVarNames).
oldClassPool _ aClass classPool.
oldClassPool isNil
ifTrue: [ aClass setClassVariables: classVarDict ]
ifFalse: [ classVarDict associationsDo:
[ :assoc | (oldClassPool includesKey: assoc key)
ifFalse:
[ aClass addClassVarName:
assoc key ] ] ].
classVarDict keys ~= aClass classPool keys
ifTrue: [ stdout nextPutAll:
'Recompilation required: different class variables!';
nl ].
sharedPoolNames _ self parseVariableString: stringOfPoolNames.
1 to: sharedPoolNames size do:
[ :i | poolName _ (sharedPoolNames at: i) asSymbol.
"### Check that the pool name starts with an uppercase letter
here."
"??? Should this create the pool if not there?"
pool _ aSystemDictionary
at: poolName
ifAbsent: [ ^self error: 'Pool name ', poolName ,
' does not exist' ].
sharedPoolNames at: i put: pool ].
"### probably should check for recompilation required here in case
the intersection of the sets of pool dictionaries shrinks"
aClass setSharedPools: sharedPoolNames.
"### not done"
aClass category: categoryName. "### need to remove the old category maybe"
"### don't know what to do with changed"
"### Need to update existing meta class (if there is one) -- change
its superclass, and fixup its old superclass to not refer to it
anymore"
^aClass
!
newMeta: newName
environment: aSystemDictionary
subclassOf: superclass
instanceVariableNames: stringOfInstVarNames
variable: variableBoolean
words: wordBoolean
pointers: pointerBoolean
classVariableNames: stringOfClassVarNames
poolDictionaries: stringOfPoolNames
category: categoryName
comment: commentString
changed: changed
| aClass variableString variableArray sharedPoolNames poolName pool |
sharedPoolNames _ self parseVariableString: stringOfPoolNames.
1 to: sharedPoolNames size do:
[ :i | poolName _ (sharedPoolNames at: i) asSymbol.
(poolName at: 1) isUppercase
ifFalse: [ ^self error: 'Pool name ', poolName,
' does not begin with an uppercase letter' ].
pool _ aSystemDictionary at: poolName
ifAbsent: [ ^self error: 'Pool name ', poolName ,
' does not exist' ].
sharedPoolNames at: i put: pool ].
aClass _ self new.
instanceClass _ aClass.
aSystemDictionary at: (newName asSymbol) put: aClass.
aClass superclass: superclass.
aClass setName: newName asSymbol.
superclass notNil
ifTrue: [ superclass addSubclass: aClass.
"Inherit instance variables from parent"
variableString _ superclass instanceVariableString
]
ifFalse: [ variableString _ '' ].
variableString _ variableString , stringOfInstVarNames.
variableArray _ self parseVariableString: variableString.
1 to: variableArray size do:
[ :i | variableArray at: i put: (variableArray at: i) asSymbol ].
aClass setInstanceVariables: variableArray.
aClass setInstanceSpec: variableBoolean words: wordBoolean
pointers: pointerBoolean instVars: variableArray size.
aClass setClassVariables: (self parseToDict: stringOfClassVarNames).
aClass setSharedPools: sharedPoolNames.
"### not done"
aClass category: categoryName.
aClass comment: commentString.
"### don't know what to do with changed"
"### Need to update existing meta class (if there is one) -- change
its superclass, and fixup its old superclass to not refer to it
anymore"
^aClass
!!
!Metaclass methodsFor: 'accessing'!
instanceClass
^instanceClass
!!
!Metaclass methodsFor: 'printing'!
printOn: aStream
instanceClass printOn: aStream.
aStream nextPutAll: ' class'
!
storeOn: aStream
self printOn: aStream
!!
!Metaclass methodsFor: 'private'!
initMetaclass
instanceVariables _ Class allInstVarNames.
instanceSpec _ Class instanceSpec
!
parseVariableString: aString
| stream |
stream _ TokenStream on: aString.
^stream contents
!
parseToDict: aString
| tokenArray dict |
tokenArray _ self parseVariableString: aString.
dict _ Dictionary new.
tokenArray do:
[ :element | dict at: element asSymbol put: nil ].
^dict
!!